home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Night Owl 6
/
Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso
/
025a
/
gsdb25.zip
/
GS_FILEH.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-08-03
|
13KB
|
484 lines
unit GS_FileH;
{-----------------------------------------------------------------------------
Changes:
5 Jan 91 - Corrected GS_FileWrite error in processing memo files
greater than 64K. Changed variable MovLth from type
word to type longint.
8 Apr 91 - Removed GS_FileWrite code that attempted to append data
to the cache buffer -- there are more opportunities for
error than the benefits provided.
5 May 91 - Added GS_FileFindFiles routine to provide a user interface
to select files that match the wildcard options passed.
This will also allow the user to go to different drives
or directories in search of a file. Requires the calling
routine to set a window prior to the call for the file
selection to display in. Also the caller must pass the
wildcard string to match against, and a boolean argument
to determine whether other drives/directories may be
selected.
Added a drive table as GS_FileDrvTab. This is a 26-element
array (0-127) for each potential drive. A 'P' is inserted
for each actual drive.
------------------------------------------------------------------------------}
interface
uses
CRT,
Dos,
GS_Strng,
GS_Error;
var
GS_FileDrvTab : array[0..127] of char;
GS_FileDrvCnt : byte;
BRCmd,
BWCmd,
IOAsk,
IORed,
IOWri,
IOPhy : word;
Procedure GS_FileAssign(var dF : file; Fname : string; BufSize : longint);
Procedure GS_FileClose(var dF : file);
Procedure GS_FileErase(var dF : file);
Function GS_FileExists(var dF : file; Fname : string) : boolean;
Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
Procedure GS_FileRename(var dF : file; FName : string);
Procedure GS_FileReset(var dF : file; len : longint);
Procedure GS_FileRewrite(var dF : file; len : longint);
Function GS_FileSize(var dF : file) : longint;
Procedure GS_FileTruncate(var dF : file; loc : longint);
Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
: string;
implementation
uses
GS_Pick,
GS_Winfc;
type
BufferPointer = ^BufferArray;
BufferArray = array[0..32767] of char;
BufrRec = record
Size : word; {Size of buffer}
CntByt : word; {Bytes stores in buffer}
Posn : longint; {Beginning byte of file in buffer}
FPosn : longint; {Last byte read + 1 in buffer}
BufPtr : BufferPointer;
end;
var
Bufr : BufrRec;
dbfErr : integer;
Blok,
TPosS,
TPosE : longint;
StrFil : string[80];
istrue : boolean;
cdriv : byte;
tdrv : byte;
regs : Registers;
ShoWin : GS_Wind_Objt;
Function InRam(var dF : file; blk, len : longint; rf : boolean) : boolean;
var
dFa : FileRec absolute dF;
RorW : string[4];
begin
istrue := false;
inc(IOAsk);
if rf then RorW := 'Read' else RorW := 'Writ';
move(dFa.UserData, Bufr, sizeof(Bufr));
if blk > -1 then TPosS := dFa.RecSize * blk
else TPosS := Bufr.FPosn;
Blok := TPosS div dFa.RecSize;
Bufr.FPosn := TPosS + dFa.RecSize * len;
if Bufr.CntByt > 0 then
begin
TPosS := TPosS - Bufr.Posn;
if (TPosS >= 0) and (TPosS < Bufr.CntByt) then
begin
TPosE := (TPosS + dFa.RecSize * len) - 1;
if TPosE <= Bufr.CntByt then istrue := true;
end;
end;
if not istrue then inc(IOPhy);
if rf then inc(IORed) else inc(IOWri);
InRam := istrue;
end;
Procedure GS_FileAssign(var dF : file; Fname : string; BufSize : longint);
var
dFa : FileRec absolute dF;
begin
Assign(df, FName);
Bufr.Posn := 0;
Bufr.FPosn := 0;
Bufr.CntByt := 0;
Bufr.Size := BufSize;
GetMem(Bufr.BufPtr, BufSize);
move(Bufr, dFa.UserData, sizeof(Bufr));
end;
Procedure GS_FileClose(var dF : file);
var
dFa : FileRec absolute dF;
begin
Close(df);
move(dFa.UserData, Bufr, sizeof(Bufr));
FreeMem(Bufr.BufPtr, Bufr.Size);
end;
Procedure GS_FileErase(var dF : file);
begin
Erase(df);
end;
Function GS_FileExists(var dF : file; Fname : string) : boolean;
begin
if (FName <> '') then
begin
{$I-}
Assign(dF, FName);
Reset(dF);
Close(dF);
{$I+}
GS_FileExists := (IOResult = 0);
end else GS_FileExists := false;
end;
Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
var
dFa : FileRec absolute dF;
Result,
LthHld : word;
StrFil : string[80];
begin
if InRam(dF, blk, len, true) then
begin
move(Bufr.BufPtr^[TPosS],dat,dFa.RecSize * len);
move(Bufr, dFa.UserData, sizeof(Bufr));
RtnRslt := len;
exit;
end;
dbfErr := 0;
begin
(*$I-*) Seek(dF, Blok); (*$I+*)
dbfErr := IOResult;
end;
IF dbfErr = 0 THEN {If seek ok, read the record}
BEGIN
inc(BRCmd);
LthHld := dFa.RecSize;
dFa.RecSize := 1;
(*$I-*)
BlockRead(dF, Bufr.BufPtr^, Bufr.Size, Result);
(*$I+*)
RtnRslt := Result div LthHld;
if RtnRslt > len then RtnRslt := len;
dbfErr := IOResult;
if dbfErr = 0 then
begin
move(Bufr.BufPtr^,dat,LthHld * len);
Bufr.CntByt := Result;
Bufr.Posn := Blok * LthHld;
Bufr.FPosn := (Blok * LthHld)+(LthHld * len);
move(Bufr, dFa.UserData, sizeof(Bufr));
end;
dFa.RecSize := LthHld;
end;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
Procedure GS_FileRename(var dF : file; Fname : string);
begin
Rename(df, FName);
end;
Procedure GS_FileReset(var dF : file; len : longint);
var
dFa : FileRec absolute dF;
i : integer;
StrFil : string[80];
begin
(*$I-*) Reset(dF, len); (*$I+*)
dbfErr := IOResult;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
Procedure GS_FileRewrite(var dF : file; len : longint);
var
dFa : FileRec absolute dF;
i : integer;
StrFil : string[80];
begin
(*$I-*) Rewrite(dF, len); (*$I+*)
dbfErr := IOResult;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
Function GS_FileSize(var dF : file) : longint;
begin
GS_FileSize := FileSize(df);
end;
Procedure GS_FileTruncate(var dF : file; loc : longint);
var
dFa : FileRec absolute dF;
begin
dbfErr := 0;
if loc <> -1 then
begin
(*$I-*) Seek(dF, loc); (*$I+*)
dbfErr := IOResult;
end;
IF dbfErr <> 0 THEN
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
Truncate(df);
end;
Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
var
dFa : FileRec absolute dF;
i : integer;
Result : word;
MovLth : longint;
StrFil : string[80];
begin
if InRam(dF, blk, len, false) then
move(dat,Bufr.BufPtr^[TPosS],dFa.RecSize * len);
{
else
begin
MovLth := (dFa.RecSize * len) + (dFa.RecSize * Blok);
if Bufr.Size >= MovLth then
begin
move(dat,Bufr.BufPtr^[dFa.RecSize * Blok],dFa.RecSize * len);
Bufr.CntByt := MovLth;
Bufr.Posn := 0;
Bufr.FPosn := MovLth;
end;
end;
move(Bufr, dFa.UserData, sizeof(Bufr));
}
dbfErr := 0;
if blk > -1 then
begin
(*$I-*) Seek(dF, blk); (*$I+*)
dbfErr := IOResult;
end;
IF dbfErr = 0 THEN {If seek ok, read the record}
BEGIN
inc(BWCmd);
(*$I-*) BlockWrite(dF, dat, len, Result); (*$I+*)
RtnRslt := Result;
dbfErr := IOResult;
end;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
: string;
var
DirInfo : SearchRec;
FilTabl : array[1..512] of string[12];
Labl : string;
DirNow,
DirNam,
DirCur : PathStr;
DSt : DirStr;
NSt : NameStr;
ESt : ExtStr;
itms : integer;
rfil : integer;
rdir : integer;
slct : integer;
lctn : integer;
wtx,
wbg,
wfg,
wti,
wbi : byte;
wx1,
wy1,
wx2,
wy2 : integer;
procedure MakeFileTable;
var
i : integer;
d : string;
v : char;
u : byte absolute v;
b : byte;
begin
itms := 0;
FindFirst(Labl, Archive, DirInfo);
while DosError = 0 do
begin
inc(itms);
FilTabl[itms] := DirInfo.Name;
FindNext(DirInfo);
end;
rfil := itms;
if itms > 0 then
GS_Pick_Item_Sort(FilTabl[1],sizeof(FilTabl[1]),itms,true);
if LookElseWhere then
begin
FindFirst('*.', Directory, DirInfo);
while DosError = 0 do
begin
if (DirInfo.Attr = directory) and (DirInfo.Name <> '.') then
begin
inc(itms);
for i := 1 to length(DirInfo.Name) do
begin
v := DirInfo.Name[i];
if v in ['A'..'Z'] then u := u + 32;
DirInfo.Name[i] := v;
end;
FilTabl[itms] := DirInfo.Name+'\';
end;
FindNext(DirInfo);
end;
rdir := itms;
if itms-rfil > 0 then
GS_Pick_Item_Sort(FilTabl[succ(rfil)],sizeof(FilTabl[1]),
itms-rfil,true);
for i := 0 to pred(GS_FileDrvCnt) do
begin
if GS_FileDrvTab[i] = 'P' then
begin
inc(itms);
FilTabl[itms] := chr(i+65)+':\';
end;
end;
end;
end;
begin
GS_Wind_GetWinSize(wx1,wy1,wx2,wy2);
if (wx2-wx1 < 16) or (wy2-wy1 < 7) then
begin
ShowError(777,'Window too small for file display');
GS_FileFindFiles := '';
exit;
end;
GS_Wind_GetColors(wtx,wbg,wfg,wti,wbi);
ShoWin.InitWin(wx1+1,wy1+1,wx1+15,wy2-3,wti,wbi,wfg,wtx,wbg,true,'',true);
GetDir(0,DirNow);
if pth <> '' then
begin
FSplit(pth, DSt, NSt, ESt);
DSt[0] := pred(DSt[0]);
(*$I-*) ChDir(DSt) (*$I+*);
end;
GetDir(0,DirNam);
DirCur := DirNam;
repeat
if DirNam[length(DirNam)] <> '\' then DirNam := DirNam + '\';
GoToXY(2,(wy2-wy1)-1);
Write('Dir = ',DirNam);
Labl := DirNam+fname;
MakeFileTable;
if itms > 0 then
begin
ShoWin.SetWin;
slct := GS_Pick_Row_Item(FilTabl, 13, itms, 1);
ShoWin.RelWin;
ClrScr;
end else slct := 0;
if slct > rfil then
begin
if slct > rdir then (*$I-*) ChDir(DirCur) (*$I+*);
DirNam := FilTabl[slct];
DirNam[0] := pred(DirNam[0]);
(*$I-*) ChDir(DirNam) (*$I+*);
GetDir(0,DirNam);
if slct > rdir then DirCur := DirNam;
end;
if (slct > 0) and (slct <= rfil) then
Labl := FilTabl[slct] else Labl := '';
lctn := pos('.',Labl);
if lctn > 0 then delete(Labl,lctn,4);
until slct <= rfil;
if DirNam[length(DirNam)] <> '\' then DirNam := DirNam + '\';
if Labl <> '' then GS_FileFindFiles := DirNam+Labl
else GS_FileFindFiles := '';
if slct = 0 then GS_FileFindFiles := '-';
ChDir(DirNow);
end;
begin
IOAsk := 0;
IOPhy := 0;
IORed := 0;
IOWri := 0;
BRCmd := 0;
BWCmd := 0;
{Build Drive Table}
regs.ah := 25;
MsDos(regs);
cdriv := regs.al;
regs.dl := cdriv;
regs.ah := 14;
MsDos(regs);
GS_FileDrvCnt := regs.al;
tdrv := 0;
while tdrv < GS_FileDrvCnt do
begin
regs.dl := tdrv;
regs.ah := 14;
MsDos(regs);
regs.ah := 25;
MsDos(regs);
if tdrv = regs.al then GS_FileDrvTab[tdrv] := 'P'
else GS_FileDrvTab[tdrv] := ' ';
inc(tdrv);
end;
regs.dl := cdriv;
regs.ah := 14;
MsDos(regs);
end.